home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / vbinst13 / vbinst.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1995-12-05  |  15.3 KB  |  417 lines
  1. VERSION 2.00
  2. Begin Form Install 
  3.    BackColor       =   &H00C0C0C0&
  4.    Caption         =   "Install"
  5.    ClientHeight    =   2745
  6.    ClientLeft      =   1245
  7.    ClientTop       =   2880
  8.    ClientWidth     =   7245
  9.    Height          =   3150
  10.    Icon            =   VBINST.FRX:0000
  11.    Left            =   1185
  12.    LinkMode        =   1  'Source
  13.    LinkTopic       =   "Form1"
  14.    ScaleHeight     =   2745
  15.    ScaleWidth      =   7245
  16.    Top             =   2535
  17.    Width           =   7365
  18.    Begin DirListBox Dir1 
  19.       Height          =   315
  20.       Left            =   2175
  21.       TabIndex        =   3
  22.       Top             =   2325
  23.       Visible         =   0   'False
  24.       Width           =   915
  25.    End
  26.    Begin CommandButton Cmd_Start 
  27.       Caption         =   "&Start"
  28.       Default         =   -1  'True
  29.       Height          =   540
  30.       Left            =   6150
  31.       TabIndex        =   8
  32.       Top             =   2025
  33.       Width           =   990
  34.    End
  35.    Begin CheckBox Check1 
  36.       BackColor       =   &H00C0C0C0&
  37.       Caption         =   "&OK to create?"
  38.       ForeColor       =   &H00000000&
  39.       Height          =   390
  40.       Left            =   150
  41.       TabIndex        =   10
  42.       Top             =   2025
  43.       Width           =   1890
  44.    End
  45.    Begin CommandButton Cmd_Cancel 
  46.       Cancel          =   -1  'True
  47.       Caption         =   "&Cancel"
  48.       Height          =   540
  49.       Left            =   6150
  50.       TabIndex        =   7
  51.       Top             =   1350
  52.       Width           =   990
  53.    End
  54.    Begin ListBox List1 
  55.       BackColor       =   &H00C0C0C0&
  56.       ForeColor       =   &H00000000&
  57.       Height          =   1005
  58.       Left            =   2250
  59.       TabIndex        =   4
  60.       Top             =   1275
  61.       Width           =   3090
  62.    End
  63.    Begin Frame Fr_Dest 
  64.       Caption         =   "D&estination SubDirectory"
  65.       Height          =   660
  66.       Left            =   3525
  67.       TabIndex        =   6
  68.       Top             =   75
  69.       Width           =   3015
  70.       Begin TextBox Txt_Dest 
  71.          ForeColor       =   &H00000000&
  72.          Height          =   315
  73.          Left            =   75
  74.          TabIndex        =   0
  75.          Top             =   300
  76.          Width           =   2865
  77.       End
  78.    End
  79.    Begin Frame Fr_Drive 
  80.       BackColor       =   &H00C0C0C0&
  81.       Caption         =   "&Destination Disk"
  82.       Height          =   660
  83.       Left            =   675
  84.       TabIndex        =   1
  85.       Top             =   75
  86.       Width           =   2760
  87.       Begin DriveListBox Drive1 
  88.          ForeColor       =   &H00000000&
  89.          Height          =   315
  90.          Left            =   75
  91.          TabIndex        =   2
  92.          Top             =   300
  93.          Width           =   2295
  94.       End
  95.    End
  96.    Begin Label Label1 
  97.       BackColor       =   &H00C0C0C0&
  98.       Caption         =   "Do you want install to create own Program Manager Group?"
  99.       ForeColor       =   &H00000000&
  100.       Height          =   615
  101.       Left            =   150
  102.       LinkTimeout     =   10
  103.       TabIndex        =   9
  104.       Top             =   1350
  105.       Width           =   1890
  106.    End
  107.    Begin Label Lbl_List 
  108.       Alignment       =   2  'Center
  109.       BackColor       =   &H00C0C0C0&
  110.       Height          =   315
  111.       Left            =   1500
  112.       TabIndex        =   5
  113.       Top             =   900
  114.       Visible         =   0   'False
  115.       Width           =   4515
  116.    End
  117. Function CheckDir (Chk As Integer) As Integer
  118. '**********************************************************************
  119. '* Check destination directory, that it does not exceed allowed       *
  120. '* 11 characters (8+3).If user gives directory such as "..\myprogram",*
  121. '* which has 9 characters in body part, Visual Basic does not         *
  122. '* generate an error code. VB just cut chrs exceeding 8 limit from    *
  123. '* left. So "..\myprogram " would be "..\myprogra", but in Program    *
  124. '* Manager Group item path is still "..\myprogram ", which would cause*
  125. '* error runing the istalled program.                                 *
  126. '* To find first "\" (backslash) from right,                          *
  127. '* we need to examine destination path string in reverse order        *
  128. '* For example "D:\WINDOWS\VBINST" would be "TSNIBV\SWODNIW\:D".      *
  129. '* Now we can use InStr function to find first occurence of "\"       *
  130. '* in destination path and check the destination directory.                                               *
  131. '**********************************************************************
  132.     DirLen% = Len(Txt_Dest.Text)
  133.     For J% = DirLen% To 1 Step -1
  134.     Temp$ = Mid$(Txt_Dest.Text, J%, 1)
  135.     Directory$ = Directory$ + Temp$
  136.     Next
  137.     'Get destination SubDirectory string
  138.     'Get directory's extension if exist
  139.     'Get directory's bodypart
  140.     Directory$ = Left$(Directory$, (InStr(Directory$, "\")))
  141.     Extension% = InStr(Directory$, ".")
  142.     BodyPart% = InStr(Directory$, "\") - Extension%
  143.     'Check extension to not exceed 3 chrs
  144.     If (Extension% = 0 Or Extension% < 5) Then
  145.     'if not extension exceed 3, check bodypart to not exceed 8 chrs
  146.     If BodyPart% > 9 Then
  147.        Chk = 0
  148.     Else
  149.         Chk = 2
  150.     End If
  151.     Else
  152.        Chk = 1
  153.     End If
  154. End Function
  155. Sub Cmd_Cancel_Click ()
  156. Const IDYES = 6  'define msgbox return value
  157. If Cmd_Cancel.Caption = "&Cancel" Then
  158.     Msg$ = "Are you sure you want to cancel install?"  'give the user a second change
  159.     Title$ = "CANCEL???"
  160.     Response% = MsgBox(Msg$, 292, Title$)  ' Get user response. '36+4+256
  161.     If Response% = IDYES Then   ' Evaluate response
  162.     Else
  163.     Exit Sub
  164.     End If
  165. End If
  166. End Sub
  167. Sub Cmd_Start_Click ()
  168. Dim ErrDirTitle As String
  169. ErrDirTitle$ = "Error creating SubDirectory"
  170.     'Set Flag for checking files overwrit
  171. WarnFlag = True
  172.     'assign drive to DestDrive variable for checking needed free diskspace
  173. DestDrive$ = Left$(LCase$(Txt_Dest.Text), 1)
  174.     'see Function NeedSpace in general section
  175. RetValue% = NeedSpace(Chk%)
  176. If Chk% = False Then Exit Sub 'not enough diskspace
  177.     'Check destination directory's number of characters.
  178.     'See Function CheckDir in general procedure
  179. RetValue% = CheckDir(Chk%)
  180. If Chk% = 0 Then
  181.     Msg$ = "Directory's bodypart exceeded 8 characters"
  182.     MsgBox Msg$, 16, ErrDirTitle$
  183.     Txt_Dest.Text = LCase$(LoadDir$) 'change back to default dir drive
  184.     Exit Sub
  185. ElseIf Chk% = 1 Then
  186.     Msg$ = "Directory's extension exceeded 3 characters"
  187.     MsgBox Msg$, 16, ErrDirTitle$
  188.     Txt_Dest.Text = LCase$(LoadDir$) 'change back to default dir drive
  189.     Exit Sub
  190. End If
  191. On Error Resume Next         'Set up error handling.
  192. DestDir$ = LCase$(Txt_Dest.Text) 'Make path specification.
  193. twobs% = InStr(DestDir$, "\\") 'check if user has put accidently two backslash
  194. If twobs% <> 0 Then            'into subdirectory's name
  195.     Msg$ = "SubDirectory has 2 (\\) backslash! "
  196.     MsgBox Msg$, 16, ErrDirTitle$
  197.     Txt_Dest.Text = LCase$(LoadDir$) 'change back to default dir drive
  198.     Drive1.Drive = Left$(WD$, 1)
  199.     Exit Sub
  200.     ChDir DestDir$           'check if directory already exist
  201.     If Err = 76 Or Err = 0 Then 'see error values
  202.     Err = 0              'reset err
  203.     MkDir DestDir$       'make directory
  204.     If Err = 76 Then    'wrong directory name
  205.         Msg$ = "Could not create such SubDirectory!, Check the SubDirectory's name."
  206.         MsgBox Msg$, 16, ErrDirTitle$
  207.         Txt_Dest.Text = LCase$(LoadDir$) 'change back to default dir drive
  208.         Drive1.Drive = Left$(WD$, 1)
  209.         Exit Sub
  210.     End If
  211.     End If
  212. End If
  213.     'change back to source directory
  214. ChDir SD$
  215.     'start installing job
  216. Install.Refresh
  217. Lbl_List.Visible = True
  218. List1.Refresh
  219. Lbl_List.Refresh
  220.     'get files from install.inf using GetPrivateProfileString API call
  221.     'to be copied windows system dir
  222. lpApplication$ = "SystemFiles"
  223. lpDefault$ = "EndMark"
  224. lpKeyName$ = "file"
  225. SubDir$ = WSD$
  226. IniCopy lpApplication$, lpKeyName$, lpDefault$, SubDir$
  227.     'get files from install.inf using GetPrivateProfileString API call
  228.     'to be copied desired subdir
  229. lpApplication$ = "Files"
  230. lpKeyName$ = "file"
  231. lpDefault$ = "EndMark"
  232. SubDir$ = DestDir$
  233. IniCopy lpApplication$, lpKeyName$, lpDefault$, SubDir$
  234.     'hides install form
  235. Install.Hide
  236.     'create a program manager group if check1 is checked
  237. If Install.Check1.Value = 1 Then
  238.     lpApplication$ = "Def"
  239.     lpDefault$ = ""
  240.     lpKeyName$ = "defgroup"
  241.     GetStringvar% = GetPrivateProfileString(lpApplication$, lpKeyName$, lpDefault$, FileStr$, nSize%, lpFileName$)
  242.     DestGroup$ = RTrim$(Left$(FileStr$, GetStringvar%))
  243.     Err = 0
  244.     'use DDE conversation with Program Manager to create
  245.     'group and program item
  246.     Label1.LinkTopic = "PROGMAN|PROGMAN"
  247.     Label1.LinkMode = 2
  248.     Label1.LinkExecute "[DeleteGroup(" + DestGroup$ + ")]"
  249.     'use LinkRequest to force windows shell
  250.     'do the DDE conversation (should disable conflicts
  251.     'if group alrady exist)
  252.     Label1.LinkRequest
  253.     'reset error
  254.     Err = 0
  255.     Label1.LinkExecute "[CreateGroup(" + DestGroup$ + ")]"
  256.     Label1.LinkRequest
  257.     Label1.LinkExecute "[ShowGroup(" + DestGroup$ + ")]"
  258.     'Add files to Program Manager group we just created
  259.     lpApplication$ = "GrpFiles"
  260.     lpDefault$ = "EndMark"
  261.     'start loop
  262.     I = 0
  263.     Do
  264.     I = I + 1
  265.     lpKeyName$ = "file" + Str$(I)
  266.     GetStringvar% = GetPrivateProfileString(lpApplication$, lpKeyName$, lpDefault$, FileStr$, nSize%, lpFileName$)
  267.         'get only characters from FileStr$ (see form load procedure)
  268.     DestPrg$ = DestDir$ + "\" + RTrim$(Left$(FileStr$, GetStringvar%))
  269.         'check named mark to end loop
  270.     If Left$(FileStr$, 7) = "EndMark" Then
  271.         Exit Do
  272.     ElseIf Left$(FileStr$, 8) = "EndMark" Then
  273.         Exit Do
  274.     End If
  275.     Label1.LinkExecute "[AddItem(" + DestPrg$ + ")]"
  276.     Loop
  277.     'close DDE chanel
  278.     Label1.LinkMode = 0
  279.     'if install is succesful let them know
  280.     If Not Err Then
  281.     Msg$ = "Installation succesfull!"
  282.     Title$ = DestGroup$
  283.     MsgBox Msg$, 64, Title$
  284.     AppActivate "Install"
  285.     Else
  286.     Msg$ = "Installation Error on creating Program Manager Group!"
  287.     Title$ = DestGroup$
  288.     MsgBox Msg$, 16, Title$
  289.     AppActivate "Install"
  290.     End If
  291.     Msg$ = "Installation succesfull!"
  292.     Title$ = "Install"
  293.     MsgBox Msg$, 64, Title$
  294.     AppActivate "Install"
  295.     End
  296. End If
  297. End Sub
  298. Sub Dir1_Change ()
  299.     'Change the default dir to windows dir
  300.     'check if windows logged drive and dir is
  301.     'drive where windows resides
  302.     a$ = LCase$(Left$(Drive1.Drive, 1))
  303.     B$ = LCase$(Left$(WD$, 1))
  304.     If a$ = B$ Then
  305.     DestDir$ = LCase$(WD$)
  306.     Else
  307.     DestDir$ = LCase$(Dir1.path)
  308.     End If
  309.     'get default dir using API call (see Cmd_Start)
  310.     lpApplication$ = "Def"
  311.     lpDefault$ = ""
  312.     lpKeyName$ = "defdir"
  313.     GetStringvar% = GetPrivateProfileString(lpApplication$, lpKeyName$, lpDefault$, FileStr$, nSize%, lpFileName$)
  314.     'default directory
  315.     'if user changes drive and current dir is the root dir
  316.     'we don't put the backslash into pathname
  317.     If Right$(DestDir$, 1) = "\" Then
  318.     Txt_Dest.Text = DestDir$ + FileStr$
  319.     Else
  320.     Txt_Dest.Text = DestDir$ + "\" + FileStr$
  321.     End If
  322. End Sub
  323. Sub Drive1_Change ()
  324.    'in case user accidently changes to drive which is
  325.    'unavailable program changes back to windows drive
  326.    On Error Resume Next
  327.    Dir1.path = Drive1.Drive
  328.    If Err Then
  329.     Dir1.path = LCase$(WD$)
  330.     Drive1.Drive = Left$(WD$, 1)
  331.    End If
  332. End Sub
  333. Sub Form_Load ()
  334.     Dim WD1 As String * 128  'win directory, because of DLL's return
  335.     Dim WSD1 As String * 128 'system directory, because of DLL's return
  336.     nWSize% = 128
  337.     nSSize% = 128
  338.     nSize% = 128 'give max size of string to return in GetPrivateprofileString
  339.     'hide wait form
  340.     Wait.Hide
  341.     ' Center on the screen
  342.     '
  343.      Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
  344.     'Apply windows Desktop color to objects
  345.     Install.BackColor = WINDOW_BACKGROUND
  346.     Fr_Drive.BackColor = APPLICATION_WORKSPACE
  347.     Fr_Dest.BackColor = APPLICATION_WORKSPACE
  348.     List1.BackColor = APPLICATION_WORKSPACE
  349.     Label1.BackColor = APPLICATION_WORKSPACE
  350.     Check1.BackColor = APPLICATION_WORKSPACE
  351.     Txt_Dest.ForeColor = WINDOW_TEXT
  352.     Drive1.ForeColor = WINDOW_TEXT
  353.     Check1.ForeColor = WINDOW_TEXT
  354.     List1.ForeColor = WINDOW_TEXT
  355.     Label1.ForeColor = WINDOW_TEXT
  356.     ' Get source drive and dir, Windows dir and System dir
  357.     'by default install create it's own Program Manager Group
  358.     Install.Check1.Value = 1
  359.     SD$ = LCase$(CurDir$) 'Source directory
  360.     If Right$(SD$, 1) = "\" Then
  361.     SD$ = SD$
  362.     Else
  363.     SD$ = SD$ + "\"
  364.     End If
  365.     Wdir% = GetWindowsDirectory(WD1$, nWSize%)'windir
  366.     Sdir% = GetSystemDirectory(WSD1$, nSSize%)'systemdir
  367.     'only value returning Wdir% and Sdir% are accepted
  368.     'etc. if Wdir%'s value is 7 we read 7 chars from left
  369.     ' global windows and system directory with leading spaces cutted off (RTrim$)
  370.     WD$ = RTrim$(LCase$(Left$(WD1$, Wdir%)))
  371.     WSD$ = RTrim$(LCase$(Left$(WSD1$, Sdir%)))
  372.     'get default dir from install.inf using API call (see Cmd_Start)
  373.     'name lpFileName
  374.     lpFileName$ = SD$ + "install.inf"
  375.     lpApplication$ = "Def"
  376.     lpDefault$ = ""
  377.     lpKeyName$ = "defdir"
  378.     GetStringvar% = GetPrivateProfileString(lpApplication$, lpKeyName$, lpDefault$, FileStr$, nSize%, lpFileName$)
  379.     'default directory
  380.     Txt_Dest.Text = WD$ + "\" + FileStr$
  381.     LoadDir$ = WD$ + "\" + FileStr$
  382.     Drive1.Drive = Left$(WD$, 1) + ":"
  383. End Sub
  384. Function NeedSpace (Chk As Integer) As Integer
  385.     'get needed diskspace from install.inf using API call GetPrivateProfileInt
  386.     lpApplication$ = "Def"
  387.     nDefault% = 0
  388.     lpKeyName$ = "needspace"
  389.     GetStringvar% = GetPrivateProfileInt(lpApplication$, lpKeyName$, nDefault%, lpFileName$)
  390.     '*********************************************************************
  391.     '* convert DestDrive$ letter to equivalent in number                 *
  392.     '* eg. c=3, d=4 and so on..                                          *
  393.     '* if Asc(DestDrive$) is 99 which is ASCII numeric value for "c",    *
  394.     '* we do subtraction from numeric value c (99-96=3), because DFree   *
  395.     '* function assign drive as number 1=a, 2=b, 3=c and so on.          *
  396.     '* I don't know if there is any function in VB, that directly convert*
  397.     '* alphabets to numeric value! Hit me with E-mail if you come up with*
  398.     '* such as function! Thanks!                                         *
  399.     '*********************************************************************
  400.     Disk% = Asc(DestDrive$) - 96   'drive ASCII value minus 96
  401.     FreeSpace = DFree(Disk%) \ 1024 'in KiloBytes
  402.     'do the checking
  403.     If FreeSpace < GetStringvar% Then
  404.     Chk% = False
  405.     Msg$ = "Not enough free DiskSpace in specified drive!"
  406.     Msg$ = Msg$ + Chr$(13) + Chr$(10) + "DiskSpace available: " + Str$(FreeSpace) + "KB"
  407.     Msg$ = Msg$ + Chr$(13) + Chr$(10) + "DiskSpace needed   : " + Str$(GetStringvar%) + "KB"
  408.     Msg$ = Msg$ + Chr$(13) + Chr$(10) + "1. Try another drive"
  409.     Msg$ = Msg$ + Chr$(13) + Chr$(10) + "          OR"
  410.     Msg$ = Msg$ + Chr$(13) + Chr$(10) + "2. Cancel install and free some DiskSpace"
  411.     Title$ = "WARNING!"
  412.     MsgBox Msg$, 16, Title$
  413.     Else
  414.        Chk% = True
  415.     End If
  416. End Function
  417.